home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / DevTools / editor < prev    next >
Encoding:
Text File  |  1992-01-02  |  4.4 KB  |  151 lines
  1. INCLUDE? .LINE JDEV:BLOCK
  2.  
  3. ONLY FORTH DEFINITIONS  DECIMAL
  4.  
  5. 1024 constant 1k
  6.      user help-level  5 help-level !
  7.  
  8. : cfa ; immediate
  9. : nfa  >name ;
  10. : small-case?  ( char -- char flag )  dup ?letter over 20 and and 0= 0= ;
  11. : both1+  1+ swap 1+ swap ;
  12. : k 1024 * ;
  13. : ctl  bl word 1+ c@  $ 1f and [compile] literal  ; immediate
  14.  
  15. : (LINE)        >R  C/L  B/BUF  */MOD  R>  B/SCR *  +
  16.                 BLOCK  +  C/L  ;
  17.  
  18. : beep  7 emit ;
  19.  
  20. hex
  21.  
  22. : BLANKS  ( addr cnt -- )  BL FILL  ;
  23. : >PAD   HERE C/L 1+ BLANKS LWORD PAD C/L 1+ MOVE ;
  24. : LINE   DUP FFFF,FFF0 AND 17 ?ERROR SCR @ (LINE)  DROP ;
  25.  
  26. VOCABULARY EDITOR HEX
  27.  
  28. ALSO EDITOR DEFINITIONS
  29.  
  30. : #LOCATE       R# @ C/L /MOD ;
  31. : #LEAD         #LOCATE LINE SWAP ;
  32. : #LAG ( --- ADR CHAR-LEFT )    #LEAD DUP >R + C/L R> - ;
  33. : -MOVE  LINE C/L MOVE UPDATE ;
  34. : H             LINE PAD 1+ C/L DUP PAD C! MOVE ;
  35. : E             LINE C/L BLANKS UPDATE ;
  36. : S  ( line#-- ) DUP 0F U> 17 ?ERROR 0F OVER -  0E SWAP 0
  37.   DO    DUP LINE OVER 1+ -MOVE 1-
  38.   LOOP  DROP E ;
  39. : D             DUP H 0F DUP ROT DO I 1+ LINE I -MOVE LOOP E ;
  40. : M   ( #chars-- )  R# +! SCREDING @ 0=
  41.    IF   CR SPACE #LEAD TYPE 5E EMIT
  42.         #LAG TYPE #LOCATE . DROP
  43.    THEN       ;
  44. : T             DUP C/L * R# ! DUP H 0 M ;
  45. : L             SCR @ LIST 0 M ;
  46. : R             PAD 1+ SWAP -MOVE ;
  47. : P             5E >PAD R ;
  48. : I             DUP S R ;
  49. : TOP           0 R# ! ;
  50. : CLEAR         SEL 10 0 DO  [ FORTH ] I  [ EDITOR ] E LOOP ;
  51. : COPY          SWAP BLOCK SWAP BUFFER 1K MOVE UPDATE   ;
  52. : NL   ( --- )  #LAG R# +! DROP ;
  53.  
  54. : MATCH  ( cursaddr #left $adr $cnt -- flag curs-movement )
  55.   2 pick >r
  56.   dup >r  3 pick >r    ( save $cnt & origcursadr  )
  57.   match?  ( matchadr? / false -- ) dup
  58.   IF    r> -    ( matchadr-origadr -- )
  59.         r@ +    ( want to point to end of string )
  60.         -1 swap ( -- true change )     dup >r ( push a dummy )
  61.   ELSE  3 xr> -rot dup 3 x>r  ( -- 0 diff-to-end )
  62.   THEN  3 xr>  3 xdrop  ;
  63.  
  64. : 1LINE ( ---F) ( scan line with cursor for match to PAD text )
  65.   ( update cursor, return boolean )
  66.   #LAG PAD COUNT MATCH R# +! ;
  67.  
  68. : EFIND          ( string at PAD over full screen, else error )
  69.   BEGIN 3FF R# @ < 
  70.         IF    TOP PAD HERE C/L 1+
  71.               MOVE 0 ERROR
  72.         THEN  1LINE 
  73.   UNTIL ;
  74.  
  75. : DELETE ( #char-to-del --- ) ( backwards at cursor by count-1)
  76.      >R #LAG + r@ -    ( save blank fill loc)
  77.      [ editor ]  #LAG R@ NEGATE R# +!     ( backup cursor )
  78.      [ editor ]  #LEAD + SWAP MOVE R> BLANKS UPDATE ;
  79.  
  80. : N             ( find next occurence of previous text  )
  81.   EFIND 0 M ;
  82.  
  83. : F             ( find occurence of text )
  84.   5E >PAD N ;
  85.  
  86. : B             ( back up cursor by text in PAD )
  87.   PAD C@ NEGATE M ;
  88.  
  89. : X             ( delete following text )
  90.   5E >PAD EFIND PAD C@ DELETE 0 M ;
  91.  
  92. : TILL          ( delete from cursor to text end on this line )
  93.   #LEAD + 5E >PAD 1LINE 0= 0 ?ERROR
  94.   #LEAD + SWAP - DELETE 0 M ;
  95.  
  96. : C             ( spread at cursor and copy in following text )
  97.   5E >PAD PAD COUNT #LAG ROT OVER
  98.   MIN >R r@ R# +!
  99.   R@ - >R DUP HERE R@ MOVE HERE 
  100.   [ EDITOR ]  #LEAD + R> MOVE
  101.   R> MOVE UPDATE 0 M ;
  102.  
  103.  
  104. FORTH DEFINITIONS
  105.  
  106. : LT  ( scr# -- )   SCR @ LOAD  ;
  107.  
  108. EDITOR DEFINITIONS
  109.  
  110. : DUPLS  (  FROML TOL --- )   DUP ROT 1-
  111.    DO   DUP    [ EDITOR ] H DUP  I  1-
  112.    LOOP  DROP  ;
  113.  
  114. : LSPLIT   ( -- )  ( CURSOR AT SPLIT-POINT )
  115.   R#  @     DUP >R    C/L / 1+ DUP   [ EDITOR ] S
  116.   ( LINE#+1 ) LINE DUP  ( ADDR ADDR ) C/L BL FILL
  117.   #LAG ROT SWAP MOVE ( UPDATE)   #LAG BL FILL ( UPDATE)
  118.   R# @ C/L / 1+  C/L * R# !    L
  119.    R#  @ R> - PAD C!  ( FOR B ) ;
  120.  
  121. : CLEAR-TILL   ( -- )  ( <TEXT> ) [ EDITOR ]
  122.      #LAG   $ 5E >PAD PAD COUNT MATCH  ( FLAG #BYTES--)
  123.      SWAP 0= 0 ?ERROR  #LEAD +  SWAP  ( ADDR CNT-- )
  124.      DUP >R BL FILL UPDATE  R> R# +!   0 M  ;
  125.  
  126. : CTILL CLEAR-TILL ;
  127.  
  128. : TT   ( LINE#-- )   DUP 1- T DROP  T  ;
  129.  
  130. : <XC-TILL>  ( dir-flag<1=UP-TO-LOW> --     input: text/\)
  131. ( LC-TILL turns appropriate ASCII-codes to lower case from )
  132. ( cursor-point 'till specified text.  UC-TILL is opposite. )
  133.   R# @ >R   [ EDITOR ] F
  134.   SCR @ BLOCK R@ +   ( Calc original address of cursor-- )
  135.   R# @ R> -          ( calc #chars ...   adr #chars-- )
  136.   OVER + SWAP
  137.   DO    [ forth ] I C@ BL OR SMALL-CASE?        ( letter? )  ( f c f-- )
  138.         IF  OVER NOT      ( and it's LOW-TO-HI? )  ( f c f-- )
  139.             IF   $ DF AND
  140.             THEN ( f c-- )  DUP I C! UPDATE
  141.         THEN DROP
  142.   LOOP  DROP ;
  143.  
  144. editor
  145. : LC-TILL       1 <XC-TILL>  ;     : LCT LC-TILL ;
  146. : UC-TILL       0 <XC-TILL>  ;     : UCT UC-TILL ;
  147.  
  148. decimal
  149.  
  150. only forth definitions
  151.